home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / source / 1svga / look.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-05-29  |  3.0 KB  |  103 lines
  1. { Look Text }
  2.  
  3. uses Dos,Txt;
  4.  
  5. var Texts:array[0..15000] of ^string;
  6.     LineMax:integer;
  7.     DirInfo:SearchRec;
  8.     Dir:DirStr; Name:NameStr; Ext:ExtStr;
  9.  
  10. { ─────────────── SetColor ─────────────── }
  11. procedure SetColor;
  12. const C:array[0..3] of byte=(0,104,54,30);
  13. var Pal:array[0..314] of byte;
  14.     Pal17:array[0..16] of byte;
  15.     I:integer;
  16. begin
  17.   VideoMode($13);
  18.   GetPalette(0,105,Pal);
  19.   VideoMode(3);
  20.   for I:=0 to 3 do SetPalette(I,1,Pal[3*C[I]]);
  21.   SetPalette(4,12,Pal[64*I]);
  22.   for I:=0 to 15 do Pal17[I]:=I; Pal17[16]:=0;
  23.   SetPalette17(Pal17);
  24. end;
  25. { ─────────────── ReadTextFile ─────────────── }
  26. procedure ReadTextFile(Filename:string);
  27. var File1:text;
  28.     St:string;
  29.     I:integer;
  30. begin
  31.   Assign(File1,Filename); Reset(File1);
  32.   LineMax:=0;
  33.   while not Eof(File1) do begin
  34.     if (LineMax>15000) or (MemAvail<256) then begin Close(File1); Exit; end;
  35.     Readln(File1,St);
  36.     for I:=1 to 255 do if St[I]=#9 then
  37.       begin Delete(St,I,1); Insert('        ',St,I); end;
  38.     GetMem(Texts[LineMax],Length(St)+1);
  39.     Texts[LineMax]^:=St;
  40.     Inc(LineMax);
  41.   end;
  42.   Close(File1);
  43. end;
  44. { ─────────────── ShowPageText ─────────────── }
  45. procedure ShowPageText(X,Y:integer);
  46. var N,I,J:integer;
  47.     St:string[80];
  48. begin
  49.   if LineMax>23 then J:=23 else J:=LineMax;
  50.   for I:=0 to J-1 do begin
  51.     N:=Length(Texts[Y+I]^)-X;
  52.     if N<0 then N:=0; if N>80 then N:=80;
  53.     St[0]:=#80; FillChar(St[1],80,' ');
  54.     Move(Texts[Y+I]^[X+1],St[1],N);
  55.     PrintText(1,2+I,$14+I shr 1,St);
  56.   end;
  57. end;
  58. { ─────────────── Look ─────────────── }
  59. procedure Look;
  60. var K,X,Y,Z:integer;
  61.     St:string[5];
  62. begin
  63.   FSplit(ParamStr(1),Dir,Name,Ext);
  64.   ReadTextFile(Dir+DirInfo.Name);
  65.   SetCurShape($20,0);
  66.   TextBar(1, 1,80, 1,$23,' ');
  67.   TextBar(1, 2,80,23,$13,' ');
  68.   TextBar(1,25,80, 1,$23,' ');
  69.   PrintText( 3, 1,$23,'Look V1.1/View Text File  (C) 1994 Jou-Nan Chen');
  70.   PrintText(56, 1,$23,'Line       Colume');
  71.   PrintText( 3,25,$23,'Arrows,PgUp,PgDn,Home,End-Scroll text   Esc-Quit');
  72.   X:=0; Y:=0; K:=0;
  73.   repeat
  74.     Str(Y+1,St); TextBar(61,1,5,1,$23,' ');
  75.     PrintText(61,1,$26,St);
  76.     Str(X+1,St); TextBar(74,1,3,1,$23,' ');
  77.     PrintText(74,1,$26,St);
  78.     if (K<>$2166) and (K<>$2146) then ShowPageText(X,Y);
  79.     K:=Key;
  80.     case K of
  81.       $4800:Dec(Y);     $5000:Inc(Y);        { Up,Down }
  82.       $4900:Dec(Y,23);  $5100:Inc(Y,23);     { PgUp,PgDn }
  83.       $4B00:Dec(X,20);  $4D00:Inc(X,20);     { Left,Right }
  84.       $4700:begin X:=0; Y:=0; end;           { Home }
  85.       $4F00:begin X:=0; Y:=LineMax-23; end;  { End }
  86.     end;
  87.     if Y>LineMax-23 then Y:=LineMax-23; if Y<0 then Y:=0;
  88.     if X>236 then X:=236; if X<0 then X:=0;
  89.   until K=$011B;    { Esc }
  90.   SetCurShape(6,7); SetCurPos(1,25); TextBar(1,25,80,1,$07,' ');
  91. end;
  92.  
  93. begin
  94.   if ParamCount=0 then
  95.     begin Writeln('Usage: Look Filename'); Halt(1); end;
  96.   if ParamCount=1 then begin
  97.     FindFirst(ParamStr(1),Archive,DirInfo);
  98.     if DosError<>0 then
  99.       begin Writeln('No such file !'); Halt(1); end;
  100.   end;
  101.   SetColor; Look; VideoMode(3);
  102. end.
  103.